{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Ochre.Compiler.CsoundSyntax
-- Copyright   :  (c) Stephen Tetley 2012
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC
--
-- Csound syntax - lowest level.
--
--------------------------------------------------------------------------------

module Ochre.Compiler.CsoundSyntax
  (

    Orchestra(..)
  , GlobalStmt(..)
  , Instrument(..)
  , Stmt(..)
  , PrimCall(..)
  , CompValue(..)
  , VarName
  , Value(..)

  , ppOrchestra
  , ppInstr

  ) where

import Ochre.Compiler.CsoundExpr
import Ochre.Compiler.Operators hiding ( unaryDocE, binDocE, relDocE )
import Ochre.Compiler.Utils hiding ( bitwiseNotU )
import Ochre.Compiler.VarId

import Text.PrettyExprHPJ                   -- package: pretty-expr-hpj

import Text.PrettyPrint.HughesPJ hiding ( TextDetails(..) )   -- package: pretty

import Data.List ( intersperse )


data Orchestra = Orchestra
    { orch_globals      :: [GlobalStmt]
    , orch_instrs       :: [Instrument]
    }
  deriving (Eq,Show)

data GlobalStmt = GlobalDecl VarId PrimCall
                | GlobalPrimCall PrimCall       -- e.g. zakinit
                
  deriving (Eq,Show)

data Instrument = Instrument
      { instr_num       :: Int
      , instr_body      :: [Stmt]
      }
  deriving (Eq,Show)


type CodeBlock = [Stmt]

data Stmt  = AssignE VarId Value                   -- lvar = expr
           | Assign1 VarId PrimCall
           | Assign2 VarId VarId PrimCall 
           | Assign3 VarId VarId VarId PrimCall
           | Assign4 VarId VarId VarId VarId PrimCall
           | OpCall PrimCall                 -- no assign, e.g. out
           | Ifte CompValue CodeBlock CodeBlock
  deriving (Eq,Show)



data PrimCall = PrimCall PrimId [Value]
  deriving (Eq,Show)

-- Comparision value 
data CompValue = CompValue RelOp Value Value
  deriving (Eq,Show)


type VarName = String


-- | Values can be passed as arguments to Opcode calls. Hence 
-- the set of values includes unary, binary and relational
-- /expressions/.
--
-- The CondE (from Syntax) constructor needs to be eliminated.
--
data Value = Int Int
           | Float Decimal
           | String String
           | Pfield Int
           | Var VarName
           | UnaryV UnaryOp Value
           | BinV BinOp Value Value
           | CondV CompValue Value Value
           | FunCallV PrimId [Value]
  deriving (Eq,Show)


--------------------------------------------------------------------------------
-- Pretty print


ppOrchestra :: Orchestra -> Doc
ppOrchestra (Orchestra gbls insts)  = gbls_doc $+$ blank_doc $+$ insts_doc
  where
    insts_doc = vcat $ map (\i -> ppInstr i $+$ blank_doc) insts
    gbls_doc  = vcat $ map ppGlobalStmt gbls

ppGlobalStmt :: GlobalStmt -> Doc
ppGlobalStmt (GlobalDecl vid prim)  = text (varName vid) <+> ppPrimCall prim
ppGlobalStmt (GlobalPrimCall prim)  = ppPrimCall prim
    

ppInstr :: Instrument -> Doc
ppInstr (Instrument i body) = 
        text "instr" <+> int i
    $+$ (vcat $ map ppStmt body)
    $+$ text "endin"

ppStmt :: Stmt -> Doc
ppStmt (AssignE vid v)          = 
    padTextR 11 (varName vid) <+> char '=' <+> ppValue v

ppStmt (Assign1 vid p)          = 
    padTextR 11 (varName vid) <+> ppPrimCall p

ppStmt (Assign2 v1 v2 p)        = padTextR 11 ss <+> ppPrimCall p
  where
    ss = varName v1 ++ "," ++ varName v2

ppStmt (Assign3 v1 v2 v3 p)     = padTextR 11 ss <+> ppPrimCall p
  where
    ss = varName v1 ++ "," ++ varName v2 ++ "," ++ varName v3

ppStmt (Assign4 v1 v2 v3 v4 p)  = padTextR 11 ss <+> ppPrimCall p
  where
    ss = concat $ intersperse "," $ map varName [v1,v2,v3,v4]

ppStmt (OpCall p)               = padTextR 11 "" <+> ppPrimCall p

ppStmt (Ifte cv b1 b2)          = 
    padTextR 11 "" <+> text "if" <+> parens (ppCompValue cv) 
                   <+> text "then"
                   $+$ nest 2 (vcat $ map ppStmt b1)
                   $+$ text "else"
                   $+$ nest 2 (vcat $ map ppStmt b2)
                   $+$ text "endif"


ppPrimCall :: PrimCall -> Doc
ppPrimCall (PrimCall prim es)   = 
    text (prim_name prim) <+> commaSep (map ppValue es)


ppCompValue :: CompValue -> Doc
ppCompValue (CompValue op v1 v2) = 
    unparse $ relDocE op (exprValue v1) (exprValue v2)

ppValue :: Value -> Doc
ppValue = unparse . exprValue

exprValue :: Value -> DocE
exprValue (Int i)                   = Atom $ int i
exprValue (Float d)                 = Atom $ truncatedDouble $ realToFrac d
exprValue (String s)                = Atom $ doubleQuotes $ text s
exprValue (Pfield i)                = Atom $ text $ 'p' : show i
exprValue (Var v)                   = Atom $ text v
exprValue (UnaryV op v)             = unaryDocE op (exprValue v)
exprValue (BinV op v1 v2)           = binDocE op (exprValue v1) (exprValue v2)
exprValue (CondV cv v1 v2)          = 
    Atom $ parens (ppCompValue cv <+> char '?'   <+> ppValue v1
                                  <+> char ':'   <+> ppValue v2 )

exprValue (FunCallV pid vs)         = 
    Atom $ text (prim_name pid) <> tupled (map ppValue vs)


